home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / f2c-9510.000 / f2c-9510 / f2c-951007-libs-1.1 / src / vax.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-10-07  |  11.7 KB  |  567 lines
  1. /****************************************************************
  2. Copyright 1990, 1992, 1993, 1994 by AT&T Bell Laboratories and Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. #include "defs.h"
  25. #include "pccdefs.h"
  26. #include "output.h"
  27.  
  28. int regnum[] =  {
  29.     11, 10, 9, 8, 7, 6 };
  30.  
  31. /* Put out a constant integer */
  32.  
  33.  void
  34. #ifdef KR_headers
  35. prconi(fp, n)
  36.     FILEP fp;
  37.     ftnint n;
  38. #else
  39. prconi(FILEP fp, ftnint n)
  40. #endif
  41. {
  42.     fprintf(fp, "\t%ld\n", n);
  43. }
  44.  
  45.  
  46.  
  47. /* Put out a constant address */
  48.  
  49.  void
  50. #ifdef KR_headers
  51. prcona(fp, a)
  52.     FILEP fp;
  53.     ftnint a;
  54. #else
  55. prcona(FILEP fp, ftnint a)
  56. #endif
  57. {
  58.     fprintf(fp, "\tL%ld\n", a);
  59. }
  60.  
  61.  
  62.  void
  63. #ifdef KR_headers
  64. prconr(fp, x, k)
  65.     FILEP fp;
  66.     Constp x;
  67.     int k;
  68. #else
  69. prconr(FILEP fp, Constp x, int k)
  70. #endif
  71. {
  72.     char *x0, *x1;
  73.     char cdsbuf0[64], cdsbuf1[64];
  74.  
  75.     if (k > 1) {
  76.         if (x->vstg) {
  77.             x0 = x->Const.cds[0];
  78.             x1 = x->Const.cds[1];
  79.             }
  80.         else {
  81.             x0 = cds(dtos(x->Const.cd[0]), cdsbuf0);
  82.             x1 = cds(dtos(x->Const.cd[1]), cdsbuf1);
  83.             }
  84.         fprintf(fp, "\t%s %s\n", x0, x1);
  85.         }
  86.     else
  87.         fprintf(fp, "\t%s\n", x->vstg ? x->Const.cds[0]
  88.                 : cds(dtos(x->Const.cd[0]), cdsbuf0));
  89. }
  90.  
  91.  
  92.  char *
  93. #ifdef KR_headers
  94. memname(stg, mem)
  95.     int stg;
  96.     long mem;
  97. #else
  98. memname(int stg, long mem)
  99. #endif
  100. {
  101.     static char s[20];
  102.  
  103.     switch(stg)
  104.     {
  105.     case STGCOMMON:
  106.     case STGEXT:
  107.         sprintf(s, "_%s", extsymtab[mem].cextname);
  108.         break;
  109.  
  110.     case STGBSS:
  111.     case STGINIT:
  112.         sprintf(s, "v.%ld", mem);
  113.         break;
  114.  
  115.     case STGCONST:
  116.         sprintf(s, "L%ld", mem);
  117.         break;
  118.  
  119.     case STGEQUIV:
  120.         sprintf(s, "q.%ld", mem+eqvstart);
  121.         break;
  122.  
  123.     default:
  124.         badstg("memname", stg);
  125.     }
  126.     return(s);
  127. }
  128.  
  129. extern void addrlit Argdcl((Addrp));
  130.  
  131. /* make_int_expr -- takes an arbitrary expression, and replaces all
  132.    occurrences of arguments with indirection */
  133.  
  134.  expptr
  135. #ifdef KR_headers
  136. make_int_expr(e)
  137.     expptr e;
  138. #else
  139. make_int_expr(expptr e)
  140. #endif
  141. {
  142.     chainp listp;
  143.     Addrp ap;
  144.  
  145.     if (e != ENULL)
  146.     switch (e -> tag) {
  147.         case TADDR:
  148.             if (e -> addrblock.vstg == STGARG
  149.          && !e->addrblock.isarray)
  150.             e = mkexpr (OPWHATSIN, e, ENULL);
  151.             break;
  152.         case TEXPR:
  153.             e -> exprblock.leftp = make_int_expr (e -> exprblock.leftp);
  154.             e -> exprblock.rightp = make_int_expr (e -> exprblock.rightp);
  155.             break;
  156.         case TLIST:
  157.         for(listp = e->listblock.listp; listp; listp = listp->nextp)
  158.             if ((ap = (Addrp)listp->datap)
  159.              && ap->tag == TADDR
  160.              && ap->uname_tag == UNAM_CONST)
  161.                 addrlit(ap);
  162.         break;
  163.         default:
  164.             break;
  165.     } /* switch */
  166.  
  167.     return e;
  168. } /* make_int_expr */
  169.  
  170.  
  171.  
  172. /* prune_left_conv -- used in prolog() to strip type cast away from
  173.    left-hand side of parameter adjustments.  This is necessary to avoid
  174.    error messages from cktype() */
  175.  
  176.  expptr
  177. #ifdef KR_headers
  178. prune_left_conv(e)
  179.     expptr e;
  180. #else
  181. prune_left_conv(expptr e)
  182. #endif
  183. {
  184.     struct Exprblock *leftp;
  185.  
  186.     if (e && e -> tag == TEXPR && e -> exprblock.leftp &&
  187.         e -> exprblock.leftp -> tag == TEXPR) {
  188.     leftp = &(e -> exprblock.leftp -> exprblock);
  189.     if (leftp -> opcode == OPCONV) {
  190.         e -> exprblock.leftp = leftp -> leftp;
  191.         free ((charptr) leftp);
  192.     }
  193.     }
  194.  
  195.     return e;
  196. } /* prune_left_conv */
  197.  
  198.  
  199.  static int wrote_comment;
  200.  static FILE *comment_file;
  201.  
  202.  static void
  203. write_comment(Void)
  204. {
  205.     if (!wrote_comment) {
  206.         wrote_comment = 1;
  207.         nice_printf (comment_file, "/* Parameter adjustments */\n");
  208.         }
  209.     }
  210.  
  211.  static int *
  212. count_args(Void)
  213. {
  214.     register int *ac;
  215.     register chainp cp;
  216.     register struct Entrypoint *ep;
  217.     register Namep q;
  218.  
  219.     ac = (int *)ckalloc(nallargs*sizeof(int));
  220.  
  221.     for(ep = entries; ep; ep = ep->entnextp)
  222.         for(cp = ep->arglist; cp; cp = cp->nextp)
  223.             if (q = (Namep)cp->datap)
  224.                 ac[q->argno]++;
  225.     return ac;
  226.     }
  227.  
  228.  static int nu, *refs, *used;
  229.  static void awalk Argdcl((expptr));
  230.  
  231.  static void
  232. #ifdef KR_headers
  233. aawalk(P)
  234.     struct Primblock *P;
  235. #else
  236. aawalk(struct Primblock *P)
  237. #endif
  238. {
  239.     chainp p;
  240.     expptr q;
  241.  
  242.     if (P->argsp)
  243.         for(p = P->argsp->listp; p; p = p->nextp) {
  244.             q = (expptr)p->datap;
  245.             if (q->tag != TCONST)
  246.                 awalk(q);
  247.             }
  248.     if (P->namep->vtype == TYCHAR) {
  249.         if (q = P->fcharp)
  250.             awalk(q);
  251.         if (q = P->lcharp)
  252.             awalk(q);
  253.         }
  254.     }
  255.  
  256.  static void
  257. #ifdef KR_headers
  258. afwalk(P)
  259.     struct Primblock *P;
  260. #else
  261. afwalk(struct Primblock *P)
  262. #endif
  263. {
  264.     chainp p;
  265.     expptr q;
  266.     Namep np;
  267.  
  268.     for(p = P->argsp->listp; p; p = p->nextp) {
  269.         q = (expptr)p->datap;
  270.         switch(q->tag) {
  271.           case TPRIM:
  272.             np = q->primblock.namep;
  273.             if (np->vknownarg)
  274.                 if (!refs[np->argno]++)
  275.                     used[nu++] = np->argno;
  276.             if (q->primblock.argsp == 0) {
  277.                 if (q->primblock.namep->vclass == CLPROC
  278.                  && q->primblock.namep->vprocclass
  279.                         != PTHISPROC
  280.                  || q->primblock.namep->vdim != NULL)
  281.                     continue;
  282.                 }
  283.           default:
  284.             awalk(q);
  285.             /* no break */
  286.           case TCONST:
  287.             continue;
  288.           }
  289.         }
  290.     }
  291.  
  292.  static void
  293. #ifdef KR_headers
  294. awalk(e)
  295.     expptr e;
  296. #else
  297. awalk(expptr e)
  298. #endif
  299. {
  300.     Namep np;
  301.  top:
  302.     if (!e)
  303.         return;
  304.     switch(e->tag) {
  305.       default:
  306.         badtag("awalk", e->tag);
  307.       case TCONST:
  308.       case TERROR:
  309.       case TLIST:
  310.         return;
  311.       case TADDR:
  312.         if (e->addrblock.uname_tag == UNAM_NAME) {
  313.             np = e->addrblock.user.name;
  314.             if (np->vknownarg && !refs[np->argno]++)
  315.                 used[nu++] = np->argno;
  316.             }
  317.         e = e->addrblock.memoffset;
  318.         goto top;
  319.       case TPRIM:
  320.         np = e->primblock.namep;
  321.         if (np->vknownarg && !refs[np->argno]++)
  322.             used[nu++] = np->argno;
  323.         if (e->primblock.argsp && np->vclass != CLVAR)
  324.             afwalk((struct Primblock *)e);
  325.         else
  326.             aawalk((struct Primblock *)e);
  327.         return;
  328.       case TEXPR:
  329.         awalk(e->exprblock.rightp);
  330.         e = e->exprblock.leftp;
  331.         goto top;
  332.       }
  333.     }
  334.  
  335.  static chainp
  336. #ifdef KR_headers
  337. argsort(p0)
  338.     chainp p0;
  339. #else
  340. argsort(chainp p0)
  341. #endif
  342. {
  343.     Namep *args, q, *stack;
  344.     int i, nargs, nout, nst;
  345.     chainp *d, *da, p, rv, *rvp;
  346.     struct Dimblock *dp;
  347.  
  348.     if (!p0)
  349.         return p0;
  350.     for(nargs = 0, p = p0; p; p = p->nextp)
  351.         nargs++;
  352.     args = (Namep *)ckalloc(i = nargs*(sizeof(Namep) + 2*sizeof(chainp)
  353.             + 2*sizeof(int)));
  354.     memset((char *)args, 0, i);
  355.     stack = args + nargs;
  356.     d = (chainp *)(stack + nargs);
  357.     refs = (int *)(d + nargs);
  358.     used = refs + nargs;
  359.  
  360.     for(p = p0; p; p = p->nextp) {
  361.         q = (Namep) p->datap;
  362.         args[q->argno] = q;
  363.         }
  364.     for(p = p0; p; p = p->nextp) {
  365.         q = (Namep) p->datap;
  366.         if (!(dp = q->vdim))
  367.             continue;
  368.         i = dp->ndim;
  369.         while(--i >= 0)
  370.             awalk(dp->dims[i].dimexpr);
  371.         awalk(dp->basexpr);
  372.         while(nu > 0) {
  373.             refs[i = used[--nu]] = 0;
  374.             d[i] = mkchain((char *)q, d[i]);
  375.             }
  376.         }
  377.     for(i = nst = 0; i < nargs; i++)
  378.         for(p = d[i]; p; p = p->nextp)
  379.             refs[((Namep)p->datap)->argno]++;
  380.     while(--i >= 0)
  381.         if (!refs[i])
  382.             stack[nst++] = args[i];
  383.     if (nst == nargs) {
  384.         rv = p0;
  385.         goto done;
  386.         }
  387.     nout = 0;
  388.     rv = 0;
  389.     rvp = &rv;
  390.     while(nst > 0) {
  391.         nout++;
  392.         q = stack[--nst];
  393.         *rvp = p = mkchain((char *)q, CHNULL);
  394.         rvp = &p->nextp;
  395.         da = d + q->argno;
  396.         for(p = *da; p; p = p->nextp)
  397.             if (!--refs[(q = (Namep)p->datap)->argno])
  398.                 stack[nst++] = q;
  399.         frchain(da);
  400.         }
  401.     if (nout < nargs)
  402.         for(i = 0; i < nargs; i++)
  403.             if (refs[i]) {
  404.                 q = args[i];
  405.                 errstr("Can't adjust %.38s correctly\n\
  406.     due to dependencies among arguments.",
  407.                     q->fvarname);
  408.                 *rvp = p = mkchain((char *)q, CHNULL);
  409.                 rvp = &p->nextp;
  410.                 frchain(d+i);
  411.                 }
  412.  done:
  413.     free((char *)args);
  414.     return rv;
  415.     }
  416.  
  417.  void
  418. #ifdef KR_headers
  419. prolog(outfile, p)
  420.     FILE *outfile;
  421.     register chainp p;
  422. #else
  423. prolog(FILE *outfile, register chainp p)
  424. #endif
  425. {
  426.     int addif, addif0, i, nd, size;
  427.     int *ac;
  428.     register Namep q;
  429.     register struct Dimblock *dp;
  430.     chainp p0, p1;
  431.  
  432.     if(procclass == CLBLOCK)
  433.         return;
  434.     p0 = p;
  435.     p1 = p = argsort(p);
  436.     wrote_comment = 0;
  437.     comment_file = outfile;
  438.     ac = 0;
  439.  
  440. /* Compute the base addresses and offsets for the array parameters, and
  441.    assign these values to local variables */
  442.  
  443.     addif = addif0 = nentry > 1;
  444.     for(; p ; p = p->nextp)
  445.     {
  446.         q = (Namep) p->datap;
  447.         if(dp = q->vdim)    /* if this param is an array ... */
  448.         {
  449.         expptr Q, expr;
  450.  
  451.         /* See whether to protect the following with an if. */
  452.         /* This only happens when there are multiple entries. */
  453.  
  454.         nd = dp->ndim - 1;
  455.         if (addif0) {
  456.             if (!ac)
  457.                 ac = count_args();
  458.             if (ac[q->argno] == nentry)
  459.                 addif = 0;
  460.             else if (dp->basexpr
  461.                     || dp->baseoffset->constblock.Const.ci)
  462.                 addif = 1;
  463.             else for(addif = i = 0; i <= nd; i++)
  464.                 if (dp->dims[i].dimexpr
  465.                 && (i < nd || !q->vlastdim)) {
  466.                     addif = 1;
  467.                     break;
  468.                     }
  469.             if (addif) {
  470.                 write_comment();
  471.                 nice_printf(outfile, "if (%s) {\n", /*}*/
  472.                         q->cvarname);
  473.                 next_tab(outfile);
  474.                 }
  475.             }
  476.         for(i = 0 ; i <= nd; ++i)
  477.  
  478. /* Store the variable length of each dimension (which is fixed upon
  479.    runtime procedure entry) into a local variable */
  480.  
  481.             if ((Q = dp->dims[i].dimexpr)
  482.             && (i < nd || !q->vlastdim)) {
  483.             expr = (expptr)cpexpr(Q);
  484.             write_comment();
  485.             out_and_free_statement (outfile, mkexpr (OPASSIGN,
  486.                 fixtype(cpexpr(dp->dims[i].dimsize)), expr));
  487.             } /* if dp -> dims[i].dimexpr */
  488.  
  489. /* size   will equal the size of a single element, or -1 if the type is
  490.    variable length character type */
  491.  
  492.         size = typesize[ q->vtype ];
  493.         if(q->vtype == TYCHAR)
  494.             if( ISICON(q->vleng) )
  495.             size *= q->vleng->constblock.Const.ci;
  496.             else
  497.             size = -1;
  498.  
  499.         /* Fudge the argument pointers for arrays so subscripts
  500.          * are 0-based. Not done if array bounds are being checked.
  501.          */
  502.         if(dp->basexpr) {
  503.  
  504. /* Compute the base offset for this procedure */
  505.  
  506.             write_comment();
  507.             out_and_free_statement (outfile, mkexpr (OPASSIGN,
  508.                 cpexpr(fixtype(dp->baseoffset)),
  509.                 cpexpr(fixtype(dp->basexpr))));
  510.         } /* if dp -> basexpr */
  511.  
  512.         if(! checksubs) {
  513.             if(dp->basexpr) {
  514.             expptr tp;
  515.  
  516. /* If the base of this array has a variable adjustment ... */
  517.  
  518.             tp = (expptr) cpexpr (dp -> baseoffset);
  519.             if(size < 0 || q -> vtype == TYCHAR)
  520.                 tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng));
  521.  
  522.             write_comment();
  523.             tp = mkexpr (OPMINUSEQ,
  524.                 mkconv (TYADDR, (expptr)p->datap),
  525.                 mkconv(TYINT, fixtype
  526.                 (fixtype (tp))));
  527. /* Avoid type clash by removing the type conversion */
  528.             tp = prune_left_conv (tp);
  529.             out_and_free_statement (outfile, tp);
  530.             } else if(dp->baseoffset->constblock.Const.ci != 0) {
  531.  
  532. /* if the base of this array has a nonzero constant adjustment ... */
  533.  
  534.             expptr tp;
  535.  
  536.             write_comment();
  537.             if(size > 0 && q -> vtype != TYCHAR) {
  538.                 tp = prune_left_conv (mkexpr (OPMINUSEQ,
  539.                     mkconv (TYADDR, (expptr)p->datap),
  540.                     mkconv (TYINT, fixtype
  541.                     (cpexpr (dp->baseoffset)))));
  542.                 out_and_free_statement (outfile, tp);
  543.             } else {
  544.                 tp = prune_left_conv (mkexpr (OPMINUSEQ,
  545.                     mkconv (TYADDR, (expptr)p->datap),
  546.                     mkconv (TYINT, fixtype
  547.                     (mkexpr (OPSTAR, cpexpr (dp -> baseoffset),
  548.                     cpexpr (q -> vleng))))));
  549.                 out_and_free_statement (outfile, tp);
  550.             } /* else */
  551.             } /* if dp -> baseoffset -> const */
  552.         } /* if !checksubs */
  553.  
  554.         if (addif) {
  555.             nice_printf(outfile, /*{*/ "}\n");
  556.             prev_tab(outfile);
  557.             }
  558.         }
  559.     }
  560.     if (wrote_comment)
  561.         nice_printf (outfile, "\n/* Function Body */\n");
  562.     if (ac)
  563.         free((char *)ac);
  564.     if (p0 != p1)
  565.         frchain(&p1);
  566. } /* prolog */
  567.